home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / ph.el.z / ph.el
Encoding:
Text File  |  1998-05-21  |  37.8 KB  |  1,141 lines
  1. ;;; ph.el --- Client for the CCSO directory system (aka PH/QI)
  2.  
  3. ;; Copyright (C) 1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
  6. ;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
  7. ;; Created: May 1997
  8. ;; Version: 2.6
  9. ;; Keywords: help
  10.  
  11. ;; This file is part of XEmacs
  12.  
  13. ;; XEmacs is free software; you can redistribute it and/or modify it
  14. ;; under the terms of the GNU General Public License as published by
  15. ;; the Free Software Foundation; either version 2, or (at your option)
  16. ;; any later version.
  17.  
  18. ;; XEmacs is distributed in the hope that it will be useful, but
  19. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21. ;; General Public License for more details.
  22.  
  23. ;; You should have received a copy of the GNU General Public License
  24. ;; along with XEmacs; see the file COPYING.  If not, write to 
  25. ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;; Boston, MA 02111-1307, USA.
  27.  
  28. ;;; Commentary:
  29. ;;    This package provides functions to query CCSO PH/QI nameservers
  30. ;;    through an interactive form or replace inline query strings in
  31. ;;    buffers with appropriately formatted query results (especially
  32. ;;    used to expand email addresses in message buffers). It also
  33. ;;    interfaces with the BBDB package to let you register entries of
  34. ;;    the CCSO PH/QI directory into your own database.  The CCSO PH/QI
  35. ;;    white pages system was developped at UIUC and is in use in more
  36. ;;    than 300 sites in the world. The distribution can be found at
  37. ;;    ftp://uiarchive.cso.uiuc.edu/pub/packages/ph Traditionally the
  38. ;;    server is called QI while the client is called PH.
  39.  
  40. ;;; Installation:
  41. ;;    This package uses the custom and widget libraries. If they are not already 
  42. ;;    installed on your system get them from http://www.dina.kvl.dk/~abraham/custom/
  43. ;;    Then uncomment and add the following to your .emacs file:
  44. ;;      (require 'ph)
  45. ;;      (eval-after-load "message"
  46. ;;                       '(define-key message-mode-map [(control ?c) (tab)] 'ph-expand-inline))
  47. ;;      (eval-after-load "mail"
  48. ;;                       '(define-key mail-mode-map [(control ?c) (tab)] 'ph-expand-inline))
  49. ;;    See the info file for details
  50.  
  51. ;;    This package runs under XEmacs 19.15 or 20 and under Emacs 19.34 and above
  52.  
  53. ;;; Usage:
  54. ;;    - Provided you did the installation as proposed in the above section, 
  55. ;;      inline expansion will be available when you compose an email
  56. ;;      message. Type the name of somebody recorded in your PH/QI server and hit
  57. ;;      C-c TAB, this will overwrite the name with the corresponding email 
  58. ;;      address
  59. ;;    - M-x ph-customize to customize inline expansion and other features to
  60. ;;      your needs.
  61. ;;    - Look for the Ph submenu in the Tools menu for more.
  62. ;;    See the info file for details.
  63.  
  64. ;;; Code:
  65.  
  66. (require 'wid-edit)
  67. (require 'custom)
  68.  
  69. (if (not (fboundp 'make-overlay))
  70.     (require 'overlay))
  71. (if (locate-library "timer")
  72.     (require 'timer))
  73.  
  74. (autoload 'custom-menu-create "cus-edit")
  75. (autoload 'bbdb-create-internal "bbdb-com")
  76. (autoload 'bbdb-parse-phone-number "bbdb-com")
  77. (autoload 'bbdb-display-records "bbdb")
  78.  
  79. ;;{{{      Package customization variables
  80.  
  81. (defgroup ph nil 
  82.   "CCSO (PH/QI) directory system client"
  83.   :group 'mail
  84.   :group 'comm)
  85.  
  86. (defcustom ph-server nil
  87.   "*The name or IP address of the CCSO (PH/QI) server.
  88. A port number may be specified by appending a colon and a
  89. number to the name of the server."
  90.   :type  '(string :tag "Server")
  91.   :group 'ph)
  92.  
  93. (defcustom ph-strict-return-matches t
  94.   "*If non-nil, entries that do not contain all the requested return fields are ignored."
  95.   :type  'boolean
  96.   :group 'ph)
  97.  
  98. (defcustom ph-default-return-fields nil
  99.   "*A list of the default fields to extract from CCSO entries.
  100. If it contains `all' then all available fields are returned.
  101. nil means return the default fields as configured in the server."
  102.   :type  '(repeat (symbol :tag "Field name"))
  103.   :group 'ph)
  104.  
  105. (defcustom ph-multiple-match-handling-method 'select
  106.   "*What to do when multiple entries match a query for an inline expansion.
  107. Possible values are: 
  108. `first' (equivalent to nil) which means consider the first match.
  109. `select' pop-up a selection buffer
  110. `all' use all matches
  111. `abort' the operation is aborted, an error is signaled"
  112.   :type  '(choice :menu-tag "Method"
  113.           (const :menu-tag "First"  first)
  114.           (const :menu-tag "Select" select)
  115.           (const :menu-tag "All"    all)
  116.           (const :menu-tag "Abort"  abort)
  117.           (const :menu-tag "None" nil))
  118.   :group 'ph)
  119.  
  120. (defcustom ph-duplicate-fields-handling-method '((email . duplicate))
  121.   "*A method to handle entries containing duplicate fields.
  122. This is either an alist (FIELD . METHOD) or a symbol METHOD.
  123. The alist form of the variable associates a method to an individual field,
  124. the second form specifies a method applicable to all fields.
  125. Available methods are:
  126. `list' or nil lets the value of the field be a list of values
  127. `first' keeps the first value and discards the others,
  128. `concat' concatenates the values into a single multiline string,
  129. `duplicate' duplicates the entire entry into as many instances as 
  130. different values."
  131.   :type '(choice (const :menu-tag "List" list)
  132.          (const :menu-tag "First" first)
  133.          (const :menu-tag "Concat" concat)
  134.          (const :menu-tag "Duplicate" duplicate)
  135.          (repeat :menu-tag "Per Field Specification"
  136.              :tag "Per Field Specification"
  137.              (cons :tag "Field/Method"
  138.                    :value (nil . list)
  139.                    (symbol :tag "Field name")
  140.                    (choice :tag "Method"
  141.                        :menu-tag "Method"
  142.                        (const :menu-tag "List" list)
  143.                        (const :menu-tag "First" first)
  144.                        (const :menu-tag "Concat" concat)
  145.                        (const :menu-tag "Duplicate" duplicate)))))
  146.   :group 'ph
  147. )
  148.  
  149. (defcustom ph-inline-query-format-list nil
  150.   "*Format of an inline expansion query.
  151. If the inline query string consists of several words, this list specifies 
  152. how these individual words are associated to CCSO database field names.
  153. If nil all the words will be mapped onto the default CCSO database key."
  154.   :type  '(repeat (symbol :tag "Field name"))
  155.   :group 'ph)
  156.  
  157. (defcustom ph-expanding-overwrites-query t
  158.   "*If non nil, expanding a query overwrites the query string"
  159.   :type  'boolean
  160.   :group 'ph)
  161.  
  162. (defcustom ph-inline-expansion-format '("%s" email)
  163.   "*A list specifying the format of the expansion of inline queries.
  164. This variable controls what ph-expand-inline actually inserts in the buffer.
  165. First element is a string passed to format. Remaining elements are symbols
  166. indicating CCSO database field names, corresponding field values are passed
  167. as additional arguments to format."
  168.   :type  '(list (string :tag "Format String")
  169.         (repeat :inline t
  170.             :tag "Field names"
  171.             (symbol :tag "")))
  172.   :group 'ph)
  173.  
  174. (defcustom ph-form-fields '(name email phone)
  175.   "*A list of fields presented in the query form."
  176.   :tag   "Default Fields in Query Forms"
  177.   :type  '(repeat (symbol :tag "Field name"))
  178.   :group 'ph)
  179.  
  180. (defcustom ph-fieldname-formstring-alist '((url . "URL")
  181.                        (callsign . "HAM Call Sign")
  182.                        (id . "ID")
  183.                        (email . "E-Mail")
  184.                        (firstname . "First Name"))
  185.   "*A mapping of CCSO database field names onto prompt strings used in query/response forms.
  186. Prompt strings for fields that are not in this are derived by splitting the field name
  187. at `_' signs and capitalizing the individual words."
  188.   :tag   "Mapping of Field Names onto Prompt Strings"
  189.   :type  '(repeat (cons :tag "Field"
  190.             (symbol :tag "Name")
  191.                 (string :tag "Prompt string")))
  192.   :group 'ph)
  193.  
  194. (defcustom ph-bbdb-conversion-alist '((name . name)
  195.                       (net . email)
  196.                       (address . (ph-bbdbify-address address "Address"))
  197.                       (phone . ((ph-bbdbify-phone phone "Phone")
  198.                         (ph-bbdbify-phone office_phone "Office Phone"))))
  199.   "*A mapping from BBDB to PH/QI fields.
  200. This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where
  201. BBDB-FIELD is the name of a field that must be defined in your BBDB
  202. environment (standard field names are `name', `company', `net', `phone',
  203. `address' and `notes').  SPEC-OR-LIST is either a single SPEC or a list
  204. of SPECs. Lists of specs are valid only for the `phone' and `address'
  205. BBDB fields.  SPECs are sexps which are evaluated:
  206.   a string evaluates to itself
  207.   a symbol evaluates to the symbol value. Symbols naming PH/QI fields
  208.     present in the record evaluate to the value of the field in the record
  209.   a form is evaluated as a function. The argument list may contain PH/QI 
  210.     field names which eval to the corresponding values in the
  211.     record. The form evaluation should return something appropriate for
  212.     the particular BBDB-FIELD (see bbdb-create-internal).
  213.     ph-bbdbify-phone and ph-bbdbify-address are provided as convenience
  214.     functions to parse phones and addresses."
  215.   :tag "BBDB to CCSO Field Name Mapping"
  216.   :type '(repeat (cons :tag "Field Name"
  217.                (symbol :tag "BBDB Field")
  218.                (sexp :tag "Conversion Spec")))
  219.   :group 'ph)
  220.  
  221. (defcustom ph-options-file "~/.ph-options"
  222.   "*A file where the `servers' hotlist (and maybe other variables in the future) is stored."
  223.   :type '(file :Tag "File Name:"))
  224.  
  225. (defcustom ph-mode-hook nil
  226.   "*A list of functions called when ph-mode is entered in buffers displaying query results."
  227.   :type '(repeat (sexp :tag "Hook")))
  228.  
  229. ;;}}}
  230.  
  231.  
  232. ;;{{{      Internal cooking
  233.  
  234.  
  235. (defconst ph-xemacs-p (string-match "XEmacs" emacs-version))
  236. (defconst ph-fsfemacs-p (not ph-xemacs-p))
  237. (defconst ph-xemacs-mule-p (and ph-xemacs-p
  238.                  (featurep 'mule)))
  239. (defconst ph-fsfemacs-mule-p (and ph-fsfemacs-p
  240.                    (featurep 'mule)))
  241.  
  242. (defvar ph-server-hotlist nil)
  243.  
  244. (defconst ph-default-server-port 105
  245.   "Default TCP port for CCSO directory services")
  246.  
  247. (defvar ph-form-widget-list nil)
  248. (defvar ph-process-buffer nil)
  249. (defvar ph-read-point)
  250.  
  251. ;;; Load the options file
  252. (if (and (and (locate-library ph-options-file)
  253.           (message ""))        ; Remove modeline message
  254.      (not (featurep 'ph-options-file)))
  255.     (load ph-options-file))
  256.      
  257. ;;; FSF Emacs does not provide that one
  258. (if (not (fboundp 'split-string))
  259.     (defun split-string (string pattern)
  260.       "Return a list of substrings of STRING which are separated by PATTERN."
  261.       (let (parts (start 0))
  262.     (while (string-match pattern string start)
  263.       (setq parts (cons (substring string start (match-beginning 0)) parts)
  264.         start (match-end 0)))
  265.     (nreverse (cons (substring string start) parts))
  266.     )))
  267.  
  268. (defun ph-mode ()
  269.   "Major mode used in buffers displaying the results of PH queries.
  270. There is no sense in calling this command from a buffer other than
  271. one containing the results of a PH query.
  272.  
  273. Available bindings:
  274. \\{ph-mode-map}"
  275.   (interactive)
  276.   (kill-all-local-variables)
  277.   (setq major-mode 'ph-mode)
  278.   (setq mode-name "PH")
  279.   (use-local-map ph-mode-map)
  280.   (setq mode-popup-menu (ph-menu))
  281.   (run-hooks 'ph-mode-hook)
  282. )
  283.  
  284. (defun ph-display-records (records &optional raw-field-names)
  285.   "Display the record list RECORDS in a formatted buffer. 
  286. If RAW-FIELD-NAMES is non-nil, field names will be formatted to look
  287. more attractive byi capitalizing and forming strings."
  288.   (let ((buffer (get-buffer-create "*PH Query Results*"))
  289.     inhibit-read-only
  290.     precords
  291.     (width 0)
  292.     beg field-beg
  293.     field-name)
  294.     (switch-to-buffer buffer)    
  295.     (setq buffer-read-only t)
  296.     (setq inhibit-read-only t)
  297.     (erase-buffer)
  298.     (insert "PH Query Result\n")
  299.     (insert "===============\n\n\n")
  300.     (if (null records)
  301.     (insert "No match found.\n"
  302.         (if ph-strict-return-matches
  303.             "Try setting ph-strict-return-matches to nil or change ph-default-return-fields."
  304.           ""))
  305.       ;; Replace field names with prompt strings, compute prompt max width
  306.       (setq precords
  307.         (mapcar 
  308.          (function
  309.           (lambda (record)
  310.         (mapcar 
  311.          (function
  312.           (lambda (field)
  313.             (setq field-name (if raw-field-names
  314.                      (symbol-name (car field))
  315.                        (or (and (assq (car field) ph-fieldname-formstring-alist)
  316.                         (cdr (assq (car field) ph-fieldname-formstring-alist)))
  317.                        (capitalize (mapconcat '(lambda (char)
  318.                                      (if (eq char ?_)
  319.                                      " "
  320.                                        (char-to-string char)))
  321.                                   (symbol-name (car field))
  322.                                   "")))))
  323.             (if (> (length field-name) width)
  324.             (setq width (length field-name)))
  325.             (cons field-name (cdr field))))
  326.          record)))
  327.          records))
  328.       (mapcar (function
  329.            (lambda (record)
  330.          (setq beg (point))
  331.          ;; Actually insert the field/value pairs
  332.          (mapcar (function
  333.               (lambda (field)
  334.                 (setq field-beg (point))
  335.                 (insert (format (concat "%" width "s: ") (car field)))
  336.                 (put-text-property field-beg (point) 'face 'bold)
  337.                 (mapcar (function 
  338.                      (lambda (val)
  339.                        (indent-to (+ 2 width))
  340.                        (insert val "\n")))
  341.                     (if (stringp (cdr field))
  342.                     (split-string (cdr field) "\n")
  343.                       (cdr field)))))
  344.              record)
  345.          ;; Store the record internal format in some convenient place
  346.          (overlay-put (make-overlay beg (point))
  347.                   'ph-record
  348.                   (car records))
  349.          (setq records (cdr records))
  350.          (insert "\n")))
  351.           precords))
  352.     (insert "\n")
  353.     (widget-create 'push-button
  354.            :notify (lambda (&rest ignore)
  355.                  (ph-query-form))
  356.            "New query")
  357.     (widget-insert " ")
  358.     (widget-create 'push-button
  359.            :notify (lambda (&rest ignore)
  360.                  (kill-this-buffer))
  361.            "Quit")
  362.     (ph-mode)
  363.     (widget-setup)      
  364.     )
  365. )
  366.  
  367. (defun ph-process-form ()
  368.   "Process the form in current buffer and display the results"
  369.   (let (query-alist
  370.     value)
  371.     (if (not (and (boundp 'ph-form-widget-list)
  372.           ph-form-widget-list))
  373.     (error "Not in a PH query form buffer")
  374.       (mapcar (function 
  375.            (lambda (wid-field)
  376.          (setq value (widget-value (cdr wid-field)))
  377.          (if (not (string= value ""))
  378.              (setq query-alist (cons (cons (car wid-field) value)
  379.                          query-alist)))))
  380.           ph-form-widget-list)
  381.       (kill-buffer (current-buffer))
  382.       (ph-display-records (ph-query-internal query-alist))
  383.     )))
  384.                
  385.                      
  386. (defun ph-query-internal (query &optional return-fields)
  387.   "Query the PH/QI server with QUERY.
  388. QUERY can be a string NAME or a list made of strings NAME 
  389. and/or cons cells (KEY . VALUE) where KEYs should be valid 
  390. CCSO database keys. NAME is equivalent to (DEFAULT . NAME) where 
  391. DEFAULT is the default key of the database) 
  392. RETURN-FIELDS is a list of database fields to return defaulting to 
  393. ph-default-return-fields."
  394.   (let (request)
  395.     (if (null return-fields)
  396.     (setq return-fields ph-default-return-fields))
  397.     (setq request 
  398.       (concat "query "
  399.           (if (stringp query)
  400.               query
  401.             (mapconcat (function (lambda (elt)
  402.                        (if (stringp elt) elt)
  403.                        (format "%s=%s" (car elt) (cdr elt))))
  404.                    query
  405.                    " "))
  406.           (if return-fields
  407.               (concat " return " (mapconcat 'symbol-name return-fields " ")))))
  408.     (and (> (length request) 6)
  409.      (ph-do-request request)
  410.      (ph-parse-query-result return-fields))))
  411.  
  412. (defun ph-parse-query-result (&optional fields)
  413.   "Return a list of alists of key/values from the record in ph-process-buffer. 
  414. Fields not in FIELDS are discarded."
  415.   (let (record records
  416.     line-regexp
  417.     current-key key value
  418.     ignore)
  419.     (save-excursion
  420.       (message "Parsing results...")
  421.       (set-buffer ph-process-buffer)
  422.       (goto-char (point-min))
  423.       (while (re-search-forward "^\\(-[0-9]+\\):\\([0-9]+\\):" nil t)
  424.     (catch 'ignore
  425.       (setq line-regexp (concat "^\\(-[0-9]+\\):" (match-string 2) ":[ \t]*\\([-a-zA-Z_]*\\)?:[ \t]*\\(.*\\)$"))
  426.       (beginning-of-line)
  427.       (setq record nil
  428.         ignore nil
  429.         current-key nil)
  430.       (while (re-search-forward line-regexp nil t)
  431.         (catch 'skip-line
  432.           (if (string= "-508" (match-string 1))
  433.           ;; A field is missing in this entry. Skip it or skip the
  434.           ;; whole record (see ph-strict-return-matches)
  435.           (if (not ph-strict-return-matches)
  436.               (throw 'skip-line t)
  437.             (while (re-search-forward line-regexp nil t))
  438.             (setq ignore t)
  439.             (throw 'ignore t)))
  440.           (setq key   (and (not (string= (match-string 2) ""))
  441.                    (intern (match-string 2)))
  442.             value (match-string 3))
  443.           (if (and current-key
  444.                (eq key current-key)) 
  445.           (setq key nil)
  446.         (setq current-key key))
  447.           (if (or (null fields)
  448.               (memq 'all fields)
  449.               (memq current-key fields))
  450.           (if key
  451.               (setq record (cons (cons key value) record)) ; New key
  452.             (setcdr (car record) (if (listp (cdar record))
  453.                          (append (cdar record) (list value))
  454.                        (list (cdar record) value))))))))
  455.     (and (not ignore)
  456.          (or (null fields)
  457.          (memq 'all fields)
  458.          (setq record (nreverse record)))
  459.          (setq record (if (not (eq 'list ph-duplicate-fields-handling-method))
  460.                    (ph-filter-duplicate-fields record)
  461.                  (list record)))
  462.          (setq records (append record records))))
  463.       )
  464.     (message "Done")
  465.     records)
  466.   )
  467.  
  468. (defun ph-filter-duplicate-fields (record)
  469.   "Filter RECORD according to ph-duplicate-fields-handling-method."
  470.   (let ((rec record)
  471.     unique
  472.     duplicates
  473.     result)
  474.  
  475.     ;; Search for multiple records
  476.     (while (and rec
  477.         (not (listp (cdar rec))))
  478.       (setq rec (cdr rec)))
  479.  
  480.     (if (null (cdar rec))
  481.     (list record)            ; No duplicate fields in this record
  482.       (mapcar (function 
  483.            (lambda (field)
  484.          (if (listp (cdr field))
  485.              (setq duplicates (cons field duplicates))
  486.            (setq unique (cons field unique)))))
  487.           record)
  488.       (setq result (list unique))
  489.       (mapcar (function
  490.            (lambda (field)
  491.          (let ((method (if (consp ph-duplicate-fields-handling-method)
  492.                    (cdr (assq (car field) ph-duplicate-fields-handling-method))
  493.                  ph-duplicate-fields-handling-method)))
  494.          (cond
  495.           ((or (null method) (eq 'list method))
  496.            (setq result 
  497.              (ph-add-field-to-records field result)))
  498.           ((eq 'first method)
  499.            (setq result 
  500.              (ph-add-field-to-records (cons (car field) (cadr field)) result)))
  501.           ((eq 'concat method)
  502.            (setq result 
  503.              (ph-add-field-to-records (cons (car field)
  504.                              (mapconcat 
  505.                               'identity
  506.                               (cdr field)
  507.                               "\n")) result)))
  508.           ((eq 'duplicate method)
  509.            (setq result
  510.              (ph-distribute-field-on-records field result)))))))
  511.           duplicates)
  512.       result)))
  513.                 
  514. (defun ph-add-field-to-records (field records)
  515.   "Add FIELD to each individual record in RECORDS and return the resulting list."
  516.   (mapcar (function
  517.        (lambda (r)
  518.          (cons field r)))
  519.       records))
  520.  
  521. (defun ph-distribute-field-on-records (field records)
  522.   "Duplicate each individual record in RECORDS according to value of FIELD.
  523. Each copy is added a new field containing one of the values of FIELD."
  524.   (let (result
  525.     (values (cdr field)))
  526.     ;; Uniquify values first
  527.     (while values
  528.       (setcdr values (delete (car values) (cdr values)))
  529.       (setq values (cdr values)))
  530.     (mapcar (function
  531.          (lambda (value)
  532.            (let ((result-list (copy-sequence records)))
  533.          (setq result-list (ph-add-field-to-records (cons (car field) value)
  534.                                   result-list))
  535.          (setq result (append result-list result))
  536.            )))
  537.         (cdr field))
  538.     result)
  539. )
  540.  
  541. (defun ph-do-request (request)
  542.   "Send REQUEST to the server. Wait for response and return the buffer containing it."
  543.   (let (process
  544.     buffer)
  545.     (unwind-protect
  546.     (progn
  547.       (message "Contacting server...")
  548.       (setq process (ph-open-session))
  549.       (if process
  550.           (save-excursion 
  551.         (set-buffer (setq buffer (process-buffer process)))
  552.         (ph-send-command process request)
  553.         (message "Request sent, waiting for reply...")
  554.         (ph-read-response process))))
  555.       (if process
  556.       (ph-close-session process)))
  557.     buffer))
  558.           
  559. (defun ph-open-session (&optional server)
  560.   "Open a connection to the given CCSO SERVER.
  561. SERVER is either a string naming the server or a list (NAME PORT)."
  562.   (let (process
  563.     host
  564.     port)
  565.     (catch 'done
  566.       (if (null server)
  567.       (setq server (or ph-server
  568.                (call-interactively 'ph-set-server))))
  569.       (string-match "\\(.*\\)\\(:\\(.*\\)\\)?" server)
  570.       (setq host (match-string 1 server))
  571.       (setq port (or (match-string 3 server)
  572.              ph-default-server-port))
  573.       (setq ph-process-buffer (get-buffer-create (format " *PH-%s*" host)))
  574.       (save-excursion
  575.     (set-buffer ph-process-buffer)
  576.     (erase-buffer)
  577.     (setq ph-read-point (point))
  578.     (and ph-xemacs-mule-p
  579.          (set-buffer-file-coding-system 'binary t)))
  580.       (setq process (open-network-stream "ph" ph-process-buffer host port))
  581.       (if (null process)
  582.       (throw 'done nil))
  583.       (process-kill-without-query process)
  584.       process)))
  585.  
  586.  
  587. (defun ph-close-session (process)
  588.   (save-excursion
  589.     (set-buffer (process-buffer process))
  590.     (ph-send-command process "quit")
  591.     (ph-read-response process)
  592.     (if (fboundp 'add-async-timeout)
  593.     (add-async-timeout 10 'delete-process process)
  594.       (run-at-time 2 nil 'delete-process process))))
  595.  
  596. (defun ph-send-command (process command)
  597.   (goto-char (point-max))
  598.   (process-send-string process command)
  599.   (process-send-string process "\r\n")
  600. )
  601.  
  602. (defun ph-read-response (process &optional return-response)
  603.   "Read a response from the PH/QI query process PROCESS.
  604. Returns nil if response starts with an error code. If the
  605. response is successful the return code or the reponse itself is returned
  606. depending on RETURN-RESPONSE"
  607.   (let ((case-fold-search nil)
  608.     return-code
  609.     match-end)
  610.     (goto-char ph-read-point)
  611.     ;; CCSO protocol : response complete if status >= 200
  612.     (while (not (re-search-forward "^\\(^[2-5].*\\):.*\n" nil t))
  613.       (accept-process-output process)
  614.       (goto-char ph-read-point))
  615.     (setq match-end (point))
  616.     (goto-char ph-read-point)
  617.     (if (and (setq return-code (match-string 1))
  618.          (setq return-code (string-to-number return-code))
  619.          (>= (abs return-code) 300))
  620.     (progn (setq ph-read-point match-end) nil)
  621.       (setq ph-read-point match-end)
  622.       (if return-response
  623.       (buffer-substring (point) match-end)
  624.     return-code))))
  625.  
  626. (defun ph-create-bbdb-record (record)
  627.   "Create a BBDB record using the RECORD alist.
  628. RECORD is an alist of (KEY . VALUE) where KEY is a symbol naming a field
  629. of the PH/QI database and VALUE is the corresponding value for the record"
  630.   ;; This function runs in a special context where lisp symbols corresponding
  631.   ;; to field names in record are bound to the corresponding values
  632.   (eval 
  633.    `(let* (,@(mapcar '(lambda (c)
  634.             (list (car c) (if (listp (cdr c))
  635.                       (list 'quote (cdr c))
  636.                     (cdr c))))
  637.              record)
  638.          bbdb-name
  639.          bbdb-company
  640.          bbdb-net
  641.          bbdb-address
  642.          bbdb-phones
  643.          bbdb-notes
  644.          spec
  645.          bbdb-record
  646.          value)
  647.  
  648.       ;; BBDB standard fields
  649.       (setq bbdb-name (ph-parse-spec (cdr (assq 'name ph-bbdb-conversion-alist)) record nil)
  650.         bbdb-company (ph-parse-spec (cdr (assq 'company ph-bbdb-conversion-alist)) record nil)
  651.         bbdb-net (ph-parse-spec (cdr (assq 'net ph-bbdb-conversion-alist)) record nil)
  652.         bbdb-notes (ph-parse-spec (cdr (assq 'notes ph-bbdb-conversion-alist)) record nil))
  653.       (setq spec (cdr (assq 'address ph-bbdb-conversion-alist)))
  654.       (setq bbdb-address (delq nil (ph-parse-spec (if (listp (car spec))
  655.                               spec
  656.                             (list spec))
  657.                           record t)))
  658.       (setq spec (cdr (assq 'phone ph-bbdb-conversion-alist)))
  659.       (setq bbdb-phones (delq nil (ph-parse-spec (if (listp (car spec))
  660.                              spec
  661.                            (list spec))
  662.                          record t)))
  663.       ;; BBDB custom fields
  664.       (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
  665.                    (mapcar (function
  666.                     (lambda (mapping)
  667.                       (if (and (not (memq (car mapping)
  668.                                   '(name company net address phone notes)))
  669.                            (setq value (ph-parse-spec (cdr mapping) record nil)))
  670.                           (cons (car mapping) value))))
  671.                        ph-bbdb-conversion-alist)))
  672.       (setq bbdb-notes (delq nil bbdb-notes))
  673.       (setq bbdb-record (bbdb-create-internal bbdb-name 
  674.                           bbdb-company 
  675.                           bbdb-net
  676.                           bbdb-address
  677.                           bbdb-phones
  678.                           bbdb-notes))
  679.  
  680.       (bbdb-display-records (list bbdb-record))
  681.       )))
  682.  
  683. (defun ph-parse-spec (spec record recurse)
  684.   "Parse the conversion SPEC using RECORD. 
  685. If RECURSE is non-nil then SPEC may be a list of atomic specs"
  686.   (cond 
  687.    ((or (stringp spec)
  688.     (symbolp spec)
  689.     (and (listp spec)
  690.          (symbolp (car spec))
  691.          (fboundp (car spec))))
  692.     (condition-case nil
  693.     (eval spec)
  694.       (void-variable nil)))
  695.    ((and recurse
  696.      (listp spec))
  697.     (mapcar '(lambda (spec-elem)
  698.            (ph-parse-spec spec-elem record nil))
  699.         spec))
  700.    (t
  701.     (error "Invalid mapping specification for `%s'. Fix ph-bbdb-conversion-alist" spec))))
  702.  
  703. (defun ph-bbdbify-address (addr location)
  704.   "Parse ADDR into a vector compatible with bbdb-create-internal.
  705. ADDR should be an address string of no more than four lines or a
  706. list of lines. 
  707. The last line is searched for the zip code, city and state name.
  708. LOCATION is used as the address location for bbdb"
  709.   (let* ((addr-components (if (listp addr)
  710.                   (reverse addr)
  711.                 (reverse (split-string addr "\n"))))
  712.      (lastl (pop addr-components))
  713.      zip city state)
  714.     (setq addr-components (nreverse addr-components))
  715.     (cond
  716.      ;; American style
  717.      ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" lastl)
  718.       (setq city (match-string 1 lastl)
  719.         state (match-string 2 lastl)
  720.         zip (string-to-number (match-string 3 lastl))))
  721.      ;; European style
  722.      ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" lastl)
  723.       (setq city (match-string 2 lastl)
  724.         zip (string-to-number (match-string 1 lastl))))
  725.      (t
  726.       (error "ph-bbdbify-address was unable to parse the address. Customize ph-bbdb-conversion-alist")))
  727.     (vector location 
  728.         (or (nth 0 addr-components) "")
  729.         (or (nth 1 addr-components) "")
  730.         (or (nth 2 addr-components) "")
  731.         (or city "")
  732.         (or state "")
  733.         zip)))
  734.  
  735. (defun ph-bbdbify-phone (phone location)
  736.   "Parse PHONE into a vector compatible with bbdb-create-internal.
  737. PHONE is either a string supposedly containing a phone number or
  738. a list of such strings which are concatenated.
  739. LOCATION is used as the phone location for bbdb"
  740.   (cond 
  741.    ((stringp phone)
  742.     (let (phone-list)
  743.       (condition-case err
  744.       (setq phone-list (bbdb-parse-phone-number phone))
  745.     (error
  746.      (if (string= "phone number unparsable." (cadr err))
  747.          (if (not (y-or-n-p (format "BBDB claims %S to be unparsable. Insert it unparsed ? " phone)))
  748.          (error "phone number unparsable.")
  749.            (setq phone-list (list (bbdb-string-trim phone))))
  750.        (signal (car err) (cdr err)))))
  751.       (if (= 3 (length phone-list))
  752.       (setq phone-list (append phone-list '(nil))))
  753.       (apply 'vector location phone-list)))
  754.    ((listp phone)
  755.     (vector location (mapconcat 'identity phone ", ")))
  756.    (t
  757.     (error "Invalid phone specification. Cannot create bbdb record"))))
  758.             
  759. ;;}}}                 
  760.  
  761. ;;{{{      High-level interfaces (interactive functions)
  762.  
  763. (defun ph-customize ()
  764.   "Customize the PH package."
  765.   (interactive)
  766.   (customize 'ph))
  767.  
  768. (defun ph-set-server (server)
  769.   "Set the server to SERVER."
  770.   (interactive "sNew PH/QI Server: ")
  771.   (message "Selected PH/QI server is now %s" server)
  772.   (setq ph-server server))
  773.  
  774. (defun ph-get-email (name)
  775.   "Get the email field of NAME from the PH/QI directory server."
  776.   (interactive "sName: ")
  777.   (let ((email (cdaar (ph-query-internal name '(email)))))
  778.     (if (interactive-p)
  779.     (if email
  780.         (message "%s" email)
  781.       (message "No record matching %s" name)))
  782.     email))
  783.  
  784. (defun ph-get-phone (name)
  785.   "Get the phone field of NAME from the PH/QI directory server."
  786.   (interactive "sName: ")
  787.   (let ((phone (cdaar (ph-query-internal name '(phone)))))
  788.     (if (interactive-p)
  789.     (if phone
  790.         (message "%s" phone)
  791.       (message "No record matching %s" name)))
  792.     phone))
  793.  
  794. (defun ph-get-field-list ()
  795.   "Return a list of valid field names for current server.
  796. When called interactively the list is formatted in a dedicated buffer
  797. otherwise a list of symbols is returned."
  798.   (interactive)
  799.   (ph-do-request "fields")
  800.   (if (interactive-p)
  801.       (let ((ph-duplicate-fields-handling-method 'list))
  802.     (ph-display-records (ph-parse-query-result) t))
  803.     (mapcar 'caar 
  804.         (ph-parse-query-result)))
  805. )
  806.  
  807. (defun ph-expand-inline (&optional replace)
  808.   "Query the server and expand the query string before point.
  809. The query string consists of the buffer substring from the point back to
  810. the preceding comma, colon or beginning of line. If it consists of more than
  811. one word the variable ph-inline-query-format-list controls how these are mapped
  812. onto CCSO database field names.
  813. After querying the server for the given string, the expansion specified by 
  814. ph-inline-expansion-format is inserted in the buffer at point. If REPLACE is t 
  815. then this expansion replaces the name in the buffer.
  816. If ph-expanding-overwrites-query is t then the meaning of REPLACE is inverted."
  817.   (interactive)
  818.   (let* ((end (point))
  819.      (beg (save-excursion
  820.         (if (re-search-backward "[:,][ \t]*" 
  821.                     (save-excursion
  822.                       (beginning-of-line)
  823.                       (point))
  824.                     'move)
  825.             (goto-char (match-end 0)))
  826.         (point)))
  827.      (words (buffer-substring beg end))
  828.      query
  829.      query-alist
  830.      (query-format ph-inline-query-format-list)
  831.      response
  832.      response-strings
  833.      key val cell)
  834.     
  835.     ;; Prepare the query
  836.     (if (or (not query-format)
  837.         (not (string-match "[ \t]+" words)))
  838.     (setq query words)
  839.       (setq words (split-string words "[ \t]+"))
  840.       (while (and words query-format)
  841.     (setq query-alist (cons (cons (car query-format) (car words)) query-alist))
  842.     (setq words (cdr words)
  843.           query-format (cdr query-format)))
  844.       (if words
  845.       (setcdr (car query-alist)
  846.           (concat (cdar query-alist) " "
  847.               (mapconcat 'identity words " "))))
  848.       ;; Uniquify query-alist
  849.       (setq query-alist (nreverse query-alist))
  850.       (while query-alist
  851.     (setq key (caar query-alist)
  852.           val (cdar query-alist)
  853.           cell (assq key query))
  854.     (if cell
  855.         (setcdr cell (concat val " " (cdr cell)))
  856.       (setq query (cons (car query-alist) query))))
  857.       (setq query-alist (cdr query-alist)))
  858.  
  859.     (setq response (ph-query-internal query (cdr ph-inline-expansion-format)))
  860.  
  861.     (if (null response)
  862.     (error "No match found")
  863.  
  864.       ;; Process response through ph-inline-expansion-format
  865.       (while response
  866.     (setq response-strings
  867.           (cons (apply 'format 
  868.                (car ph-inline-expansion-format)
  869.                (mapcar (function 
  870.                     (lambda (field)
  871.                       (or (cdr (assq field (car response))) 
  872.                       "")))
  873.                    (cdr ph-inline-expansion-format)))
  874.             response-strings))
  875.     (setq response (cdr response)))
  876.  
  877.       (if (or
  878.        (and replace (not ph-expanding-overwrites-query))
  879.        (and (not replace) ph-expanding-overwrites-query))
  880.       (delete-region beg end))
  881.       (cond 
  882.        ((or (= (length response-strings) 1)
  883.         (null ph-multiple-match-handling-method)
  884.         (eq ph-multiple-match-handling-method 'first))
  885.     (insert (car response-strings)))
  886.        ((eq ph-multiple-match-handling-method 'select)
  887.     (with-output-to-temp-buffer "*Completions*"
  888.       (display-completion-list response-strings)))
  889.        ((eq ph-multiple-match-handling-method 'all)
  890.     (insert (mapconcat 'identity response-strings ", ")))
  891.        ((eq ph-multiple-match-handling-method 'abort)
  892.     (error "There is more than one match for the query"))
  893.        ))
  894.     )
  895. )
  896.  
  897. (defun ph-query-form (&optional get-fields-from-server)
  898.   "*Display a form to query the CCSO PH/QI nameserver.
  899. If given a non-nil argument the function first queries the  server 
  900. for the existing fields and displays a corresponding form."
  901.   (interactive "P")
  902.   (let ((fields (or (and get-fields-from-server
  903.              (ph-get-field-list))
  904.             ph-form-fields))
  905.     (buffer (get-buffer-create "*PH/QI Query Form*"))
  906.     field-name
  907.     widget
  908.     (width 0)
  909.     inhibit-read-only
  910.     pt)
  911.     (switch-to-buffer buffer)
  912.     (setq inhibit-read-only t)
  913.     (erase-buffer)
  914.     (kill-all-local-variables)
  915.     (make-local-variable 'ph-form-widget-list)
  916.     (widget-insert "PH/QI Query Form\n")
  917.     (widget-insert "================\n\n")
  918.     (widget-insert "Current server is: " (or ph-server
  919.                          (call-interactively 'ph-set-server)) "\n")
  920.     ;; Loop over prompt strings to find the biggest one
  921.     (setq fields 
  922.       (mapcar (function
  923.            (lambda (field)
  924.              (setq field-name (or (and (assq field ph-fieldname-formstring-alist)
  925.                            (cdr (assq field ph-fieldname-formstring-alist)))
  926.                       (capitalize (symbol-name field))))
  927.              (if (> (length field-name) width)
  928.              (setq width (length field-name)))
  929.              (cons field field-name)))
  930.           fields))
  931.     ;; Insert the first widget out of the mapcar to leave the cursor 
  932.     ;; in the first field 
  933.     (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr (car fields))))
  934.     (setq pt (point))
  935.     (setq widget (widget-create 'editable-field :size 15))
  936.     (setq ph-form-widget-list (cons (cons (car (car fields)) widget)
  937.                      ph-form-widget-list))
  938.     (setq fields (cdr fields))
  939.     (mapcar (function
  940.          (lambda (field)
  941.            (widget-insert "\n\n" (format (concat "%" width "s: ") (cdr field)))
  942.            (setq widget (widget-create 'editable-field
  943.                        :size 15))
  944.            (setq ph-form-widget-list (cons (cons (car field) widget)
  945.                         ph-form-widget-list))))
  946.         fields)
  947.     (widget-insert "\n\n")
  948.     (widget-create 'push-button
  949.            :notify (lambda (&rest ignore)
  950.                  (ph-process-form))
  951.            "Query Server")
  952.     (widget-insert " ")
  953.     (widget-create 'push-button
  954.            :notify (lambda (&rest ignore)
  955.                  (ph-query-form))
  956.            "Reset Form")
  957.     (widget-insert " ")
  958.     (widget-create 'push-button
  959.            :notify (lambda (&rest ignore)
  960.                  (kill-this-buffer))
  961.            "Quit")
  962.     (goto-char (1+ pt)) ; 1+ for some extent boundary reason
  963.     (use-local-map widget-keymap)
  964.     (widget-setup))
  965.   )
  966.  
  967. (defun ph-bookmark-server (server)
  968.   "Add SERVER to the `servers' hotlist."
  969.   (interactive "sServer: ")
  970.   (if (member server ph-server-hotlist)
  971.       (error "%s is already in the hotlist" server)
  972.     (setq ph-server-hotlist (cons server ph-server-hotlist))
  973.     (ph-install-menu)
  974.     (ph-save-options)))
  975.  
  976. (defun ph-bookmark-current-server ()
  977.   "Add current server to the `servers' hotlist."
  978.   (interactive)
  979.   (ph-bookmark-server ph-server))
  980.  
  981. (defun ph-save-options ()
  982.   "Save options (essentially the hotlist) to ph-options-file"
  983.   (interactive)
  984.   (save-excursion
  985.     (set-buffer (find-file-noselect ph-options-file t))
  986.     ;; delete the previous setq
  987.     (let ((standard-output (current-buffer))
  988.       provide-p
  989.       setq-p)
  990.       (catch 'found
  991.     (while t
  992.       (let ((sexp (condition-case nil
  993.               (read (current-buffer))
  994.             (end-of-file (throw 'found nil)))))
  995.         (if (listp sexp)
  996.         (progn
  997.           (if (and (eq (car sexp)  'setq)
  998.                (eq (cadr sexp) 'ph-server-hotlist))
  999.               (progn 
  1000.             (delete-region (save-excursion
  1001.                      (backward-sexp)
  1002.                      (point))
  1003.                        (point))
  1004.             (setq setq-p t)))
  1005.           (if (and (eq (car sexp)  'provide)
  1006.                (equal (cadr sexp) '(quote ph-options-file)))
  1007.               (setq provide-p t))
  1008.           (if (and provide-p
  1009.                setq-p)
  1010.               (throw 'found t)))))))
  1011.       (if (eq (point-min) (point-max))
  1012.       (princ ";; This file was automatically generated by ph.el\n\n"))
  1013.       (if (not (bolp))
  1014.       (princ "\n"))
  1015.       (princ "(setq ph-server-hotlist '")
  1016.       (prin1 ph-server-hotlist)
  1017.       (princ ")\n")
  1018.       (if (not provide-p)
  1019.       (princ "(provide 'ph-options-file)\n"))
  1020.     (save-buffer)))
  1021. )
  1022.  
  1023. (defun ph-insert-record-at-point-into-bbdb ()
  1024.   "Insert record at point into the BBDB database.
  1025. This function can only be called from a PH/QI query result buffer."
  1026.   (interactive)
  1027.   (let ((record (and (overlays-at (point))
  1028.              (overlay-get (car (overlays-at (point))) 'ph-record))))
  1029.     (if (null record)
  1030.     (error "Point is not over a record.")
  1031.       (ph-create-bbdb-record record))))
  1032.  
  1033. (defun ph-try-bbdb-insert ()
  1034.   "Call ph-insert-record-at-point-into-bbdb if on a record"
  1035.   (interactive)
  1036.   (and (or (featurep 'bbdb)
  1037.        (prog1 (locate-library "bbdb") (message "")))
  1038.        (overlays-at (point))
  1039.        (overlay-get (car (overlays-at (point))) 'ph-record)
  1040.        (ph-insert-record-at-point-into-bbdb)))
  1041.  
  1042. (defun ph-move-to-next-record ()
  1043.   "Move to next record in a buffer displaying ph query results"
  1044.   (interactive)
  1045.   (if (not (eq major-mode 'ph-mode))
  1046.       (error "Not in a PH buffer")
  1047.     (let ((pt (next-overlay-change (point))))
  1048.       (if (< pt (point-max))
  1049.       (goto-char (1+ pt))
  1050.     (error "No more records after point")))))
  1051.  
  1052. (defun ph-move-to-previous-record ()
  1053.   "Move to next record in a buffer displaying ph query results"
  1054.   (interactive)
  1055.   (if (not (eq major-mode 'ph-mode))
  1056.       (error "Not in a PH buffer")
  1057.     (let ((pt (previous-overlay-change (point))))
  1058.       (if (> pt (point-min))
  1059.       (goto-char pt)
  1060.     (error "No more records before point")))))
  1061.  
  1062.  
  1063.       
  1064. ;;}}}
  1065.  
  1066. ;;{{{      Menus an keymaps
  1067.  
  1068. (require 'easymenu)
  1069.  
  1070. (defvar ph-mode-map (let ((map (make-sparse-keymap)))
  1071.               (define-key map "q" 'kill-this-buffer)
  1072.               (define-key map "x" 'kill-this-buffer)
  1073.               (define-key map "f" 'ph-query-form)
  1074.               (define-key map "b" 'ph-try-bbdb-insert)
  1075.               (define-key map "n" 'ph-move-to-next-record)
  1076.               (define-key map "p" 'ph-move-to-previous-record)
  1077.               map))
  1078. (set-keymap-parent ph-mode-map widget-keymap)
  1079.  
  1080. (defconst ph-tail-menu 
  1081.   `(["---" nil nil]
  1082.     ["Query Form" ph-query-form t]
  1083.     ["Expand Inline" ph-expand-inline t]
  1084.     ["Insert Record into BBDB" ph-insert-record-at-point-into-bbdb 
  1085.      (and (or (featurep 'bbdb)
  1086.           (prog1 (locate-library "bbdb") (message "")))
  1087.       (overlays-at (point))
  1088.       (overlay-get (car (overlays-at (point))) 'ph-record))]
  1089.     ["---" nil nil]
  1090.     ["Get Email" ph-get-email t]
  1091.     ["Get Phone" ph-get-phone t]
  1092.     ["List Valid Field Names" ph-get-field-list t]
  1093.     ["---" nil nil]    
  1094.     ,(cons "Customize" (cdr (custom-menu-create 'ph)))))
  1095.  
  1096. (defconst ph-server-menu 
  1097.   '(["---" ph-bookmark-server t]
  1098.     ["Bookmark Current Server" ph-bookmark-current-server t]
  1099.     ["New Server" ph-set-server t]))
  1100.  
  1101.  
  1102. (defun ph-menu ()
  1103.   (let (command)
  1104.     (append '("Ph")
  1105.         (list
  1106.          (append '("Server")
  1107.              (mapcar (function 
  1108.                   (lambda (server)
  1109.                 (setq command (intern (concat "ph-set-server-" server)))
  1110.                 (if (not (fboundp command))
  1111.                     (fset command `(lambda ()
  1112.                              (interactive)
  1113.                              (setq ph-server ,server)
  1114.                              (message "Selected PH/QI server is now %s" ,server))))
  1115.                 (vector server command t)))
  1116.                  ph-server-hotlist)
  1117.              ph-server-menu))
  1118.         ph-tail-menu)))
  1119.  
  1120. (defun ph-install-menu ()
  1121.   (cond 
  1122.    (ph-xemacs-p
  1123.     (add-submenu '("Tools") (ph-menu)))
  1124.    (ph-fsfemacs-p
  1125.     (easy-menu-define ph-menu-map ph-mode-map "PH Menu" (ph-menu))
  1126.     (define-key 
  1127.       global-map
  1128.       [menu-bar tools ph] 
  1129.       (cons "Ph"
  1130.         (easy-menu-create-keymaps "Ph" (cdr (ph-menu))))))
  1131.    ))
  1132.  
  1133. (ph-install-menu)
  1134.   
  1135.       
  1136. ;;}}}
  1137.  
  1138. (provide 'ph)
  1139.  
  1140. ;;; ph.el ends here
  1141.